home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / sysdef.lsp < prev    next >
Lisp/Scheme  |  1992-07-09  |  7KB  |  185 lines
  1. ;;; -*- Mode: Lisp; Base: 10; Syntax: Common-Lisp; Package: DSYS -*-
  2. ;;; File: sysdef.lisp 
  3. ;;; Author: Richard Harris
  4. ;;;
  5. ;;;    ROSE - Rensselaer Object System for Engineering
  6. ;;;    Common Lisp Implementation
  7. ;;;
  8. ;;;                Copyright (c) 1990 by 
  9. ;;;           Rensselaer Polytechnic Institute, Troy, New York.
  10. ;;;                 All Rights Reserved
  11. ;;;
  12. ;;;    THE SOFTWARE AND ACCOMPANYING WRITTEN MATERIALS ARE PROVIDED
  13. ;;;    \"AS IS\" AND WITHOUT ANY WARRANTY, INCLUDING BUT NOT LIMITED 
  14. ;;;    TO THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
  15. ;;;    A PARTICULAR PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND
  16. ;;;    PERFORMANCE OF THE SOFTWARE AND USE OF THE ACCOMPANYING WRITTEN
  17. ;;;    MATERIALS IS ASSUMED BY YOU.  IN NO EVENT SHALL RENSSELAER 
  18. ;;;    POLYTECHNIC INSTITUTE BE LIABLE FOR ANY LOST REVENUE, LOST 
  19. ;;;    PROFITS OR OTHER INCIDENTAL OR CONSEQUENTIAL DAMAGES, EVEN
  20. ;;;    IF ADVISED OF THE POSSIBILITIES OF SUCH DAMAGES, WHERE DAMAGES
  21. ;;;    ARISE OUT OF OR IN CONNECTION WITH THE USE OF, PERFORMANCE OR
  22. ;;;    NONPERFORMANCE OF THIS SOFTWARE.
  23. ;;;
  24. ;;;    This software and accompanying written materials may not be 
  25. ;;;    distributed outside your organization or outside the United 
  26. ;;;    States of America without express written authorization from
  27. ;;;    Rensselaer Polytechnic Institute.
  28. ;;;
  29. ;;;    This work has been sponsored in part by Defense Advanced Research 
  30. ;;;    Projects Agency (DARPA) under contract number MDA972-88-C0047 for
  31. ;;;     DARPA Initiative in Concurrent Engineering (DICE).  This material
  32. ;;;    may be reproduced by or for the U.S. Government pursuant to the 
  33. ;;;    copyright license under the clause at DFARS 252.227-7013 7/26/90.
  34. ;;; 
  35.  
  36. (in-package "DSYS")
  37.  
  38. (defvar *pcl-compiled-p* nil)
  39. (defvar *pcl-loaded-p* nil)
  40.  
  41. (unless (boundp 'pcl::*redefined-functions*)
  42.   (setq pcl::*redefined-functions* nil))
  43.  
  44. (defun pcl::reset-pcl-package ()        ; Try to do this safely
  45.   (let* ((vars '(pcl::*pcl-directory* 
  46.          pcl::*default-pathname-extensions* 
  47.          pcl::*pathname-extensions*
  48.          pcl::*redefined-functions*))
  49.      (names (mapcar #'symbol-name vars))
  50.      (values (mapcar #'symbol-value vars)))
  51.     (let ((pkg (find-package "PCL")))
  52.       (do-symbols (sym pkg)
  53.     (when (eq pkg (symbol-package sym))
  54.       (if (constantp sym)
  55.           (unintern sym pkg)
  56.           (progn
  57.         (makunbound sym)
  58.         (unless (eq sym 'pcl::reset-pcl-package)
  59.           (fmakunbound sym))
  60.         #+cmu (fmakunbound `(setf ,sym))
  61.         (setf (symbol-plist sym) nil))))))
  62.     (let ((pkg (find-package "SLOT-ACCESSOR-NAME")))
  63.       (when pkg
  64.     (do-symbols (sym pkg)
  65.       (makunbound sym)
  66.       (fmakunbound sym)
  67.       (setf (symbol-plist sym) nil))))
  68.     (let ((pcl (find-package "PCL")))
  69.       (mapcar #'(lambda (name value)
  70.           (let ((var (intern name pcl)))
  71.             (proclaim `(special ,var))
  72.             (set var value)))
  73.           names values))      
  74.     (dolist (sym pcl::*redefined-functions*)
  75.       (setf (symbol-function sym) (get sym ':definition-before-pcl)))
  76.     nil))
  77.  
  78. (defun reset-pcl-package ()
  79.   #-cmu
  80.   (unless (compiled-function-p #'pcl::reset-pcl-package)
  81.     (compile 'pcl::reset-pcl-package))
  82.   (pcl::reset-pcl-package)
  83.   (let ((defsys (subfile '("pcl") :name "defsys")))
  84.     (setq pcl::*pcl-directory* defsys)
  85.     (load-file defsys))
  86.   (mapc #'(lambda (path)
  87.         (setf (lfi-fwd (get-loaded-file-info path)) 0))
  88.     (pcl-binary-files)))
  89.  
  90. (defun pcl-binary-files ()
  91.   (pcl::system-binary-files 'pcl::pcl))
  92.  
  93. (defun maybe-load-defsys (&optional compile-defsys-p)
  94.   (let ((defsys (subfile '("pcl") :name "defsys"))
  95.     (*use-default-pathname-type* nil)
  96.     (*skip-load-if-loaded-p* t)
  97.     (*skip-compile-file-fwd* 0))
  98.     (set 'pcl::*pcl-directory* defsys)
  99.     (when compile-defsys-p
  100.       (compile-file defsys))
  101.     (let ((b-s 'pcl::*boot-state*))
  102.       (when (and (boundp b-s) (symbol-value b-s))
  103.     #+ignore (reset-pcl-package)))
  104.     (load-file defsys)))  
  105.  
  106. (defun maybe-load-pcl (&optional force-p)
  107.   (unless (and (null force-p)
  108.            (fboundp 'pcl::system-binary-files)
  109.            (every #'(lambda (path)
  110.               (let* ((path-fwd (file-write-date path))
  111.                  (lfi (get-loaded-file-info path)))
  112.                 (and lfi path-fwd (= path-fwd (lfi-fwd lfi)))))
  113.               (pcl-binary-files)))
  114.     (reset-pcl-package)
  115.     (pcl::load-pcl)))
  116.  
  117. (defsystem pcl
  118.     (:pretty-name "PCL")
  119.   #+akcl
  120.   (:forms 
  121.    :compile (let ((cfn (subfile '("pcl") :name "collectfn" :type "lisp")))
  122.           (unless (probe-file cfn)
  123.         (run-unix-command 
  124.          (format nil "ln -s ~A ~A"
  125.              (namestring (merge-pathnames "../cmpnew/collectfn.lsp" 
  126.                               si::*system-directory*))
  127.              (namestring cfn))))))
  128.                      
  129.   #+akcl
  130.   "collectfn"
  131.   (:forms 
  132.    :compile
  133.    (progn
  134.      (maybe-load-defsys t)
  135.      (if (and (fboundp 'pcl::operation-transformations)
  136.           (every #'(lambda (trans)
  137.              (eq (car trans) :load))
  138.              (pcl::operation-transformations 'pcl::pcl :compile)))
  139.      (maybe-load-pcl)
  140.      (let ((b-s 'pcl::*boot-state*))
  141.        (when (and (boundp b-s) (symbol-value b-s))
  142.          (reset-pcl-package))
  143.        #+akcl (compiler::emit-fn t)
  144.        #+akcl (load (merge-pathnames "../lsp/sys-proclaim.lisp" 
  145.                      si::*system-directory*))
  146.        (#+cmu with-compilation-unit #-cmu progn
  147.         #+cmu (:optimize 
  148.            '(optimize (user::debug-info #+small .5 #-small 2)
  149.                       (speed #+testing 1 #-testing 2)
  150.                       (safety #+testing 3 #-testing 0)
  151.                       #+ignore (user::inhibit-warnings 2))
  152.            :context-declarations
  153.            '(#+ignore
  154.              (:external (declare (user::optimize-interface 
  155.                       (safety 2) (debug-info 1))))))
  156.          (proclaim #+testing *testing-declaration* 
  157.                #-testing *fast-declaration*)
  158.          (pcl::compile-pcl))
  159.        (reset-pcl-package)
  160.        (maybe-load-pcl t))))
  161.    :load
  162.    (progn 
  163.      (maybe-load-pcl)
  164.      #+cmu (lisp::purify))))
  165.  
  166. (defparameter *pcl-files*
  167.   '((("systems") "lisp"
  168.      "pcl")
  169.     (("pcl") "lisp"
  170.      "sysdef"
  171.      "boot" "braid" "cache" "cloe-low" "cmu-low" "combin" "compat"
  172.      "construct" "coral-low" "cpatch" "cpl" "ctypes" "defclass" "defcombin"
  173.      "defs" "defsys" "dfun" "dlap" "env" "excl-low" "fin" "fixup" "fngen" "fsc"
  174.      "gcl-patches" "genera-low" "gold-low" "hp-low" "ibcl-low" "ibcl-patches"
  175.      "init" "iterate" "kcl-low" "kcl-patches" "lap" "low" "lucid-low" "macros"
  176.      "methods" "pcl-env-internal" "pcl-env" "pkg" "plap" "precom1" "precom2"
  177.      "precom4" "pyr-low" "pyr-patches" "quadlap" "rel-7-2-patches" "rel-8-patches"
  178.      "slots" "std-class" "sys-proclaim" "ti-low" "ti-patches" "vaxl-low" "vector" "walk"
  179.      "xerox-low" "xerox-patches")
  180.     (("pcl") "text"
  181.      "12-7-88-notes" "3-17-88-notes" "3-19-87-notes" "4-21-87-notes"
  182.      "4-29-87-notes" "5-22-87-notes" "5-22-89-notes" "8-28-88-notes"
  183.      "get-pcl" "kcl-mods" "kcl-notes" "lap" "notes" "pcl-env" "readme")))
  184.  
  185.